home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / m68primops.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.6 KB  |  273 lines
  1. (herald m68primops
  2.         (env (make-empty-early-binding-locale 'nil) constants))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define-constant call-foreign 
  28.   (primop call-foreign ()
  29.     ((primop.special? self) t)
  30.     ((primop.make-closed self)
  31.      '(lambda args (error "DEFINE-FOREIGN cannot be interpreted")))
  32.     ((primop.generate self node)
  33.      (generate-foreign-call node))))
  34.  
  35. ;;; COMPARATORS
  36. ;;;===========================================================================
  37.  
  38. (define-constant eq?
  39.   (primop eq? ()
  40.     ((primop.generate self node)
  41.      (eq?-comparator node))
  42.     ((primop.presimplify self node)
  43.      (presimplify-to-conditional node))
  44.     ((primop.make-closed self)
  45.      (make-closed-conditional self))
  46.     ((primop.conditional? self) t)
  47.     ((primop.conditional-type self node)
  48.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  49.     ((primop.type self node)
  50.      '#[type (proc #f (proc #f boolean) top top)])))
  51.        
  52. ;;; TYPE PREDICATES
  53. ;;;===========================================================================
  54.  
  55. (define-local-syntax (define-type-predicate name variant . rest)
  56.   `(define-constant ,name
  57.      ,(xcase variant
  58.         ((and)
  59.          `(make-and-type-predicate ',name . ,rest))
  60.         ((header)
  61.          `(make-header-type-predicate ',name . ,rest)))))
  62.  
  63. (define-constant make-and-type-predicate 
  64.   (primop make-and-type-predicate (name mask value)
  65.  
  66.     (((primop.simplify self node)
  67.       (simplify-parameterized-primop self node)))
  68.  
  69.     ((primop.test-code self node arg)      
  70.      (emit m68/move .l arg SCRATCH)
  71.      (emit m68/and .b (machine-num mask) SCRATCH)
  72.      (emit m68/cmp .b  (machine-num value) SCRATCH))
  73.     ((primop.presimplify self node)
  74.      (presimplify-predicate node))
  75.     ((primop.make-closed self)
  76.      (make-closed-predicate self))
  77.     ((primop.type-predicate? self) t)
  78.     ((primop.type self node)
  79.      '#[type (proc #f (proc #f boolean) top)])
  80.     ((primop.predicate-type self node)
  81.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  82.     ((primop.variant-id self) name)))
  83.  
  84. (define-constant make-header-type-predicate
  85.   (primop make-header-type-predicate (name header)
  86.  
  87.     (((primop.simplify self node)
  88.       (simplify-parameterized-primop self node)))
  89.  
  90.     ((primop.test-code self node arg)
  91.      (emit m68/move .l arg SCRATCH)
  92.      (emit m68/rol .l (machine-num 1) SCRATCH)
  93.      (emit m68/cmp .b (machine-num (fx* header 2)) SCRATCH))
  94.     ((primop.presimplify self node)
  95.      (presimplify-predicate node))
  96.     ((primop.make-closed self)
  97.      (make-closed-predicate self))
  98.     ((primop.type-predicate? self) t)
  99.     ((primop.type self node)
  100.      '#[type (proc #f (proc #f boolean) top)])
  101.     ((primop.predicate-type self node)
  102.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  103.     ((primop.variant-id self) name)))
  104.  
  105.                      
  106. (define-type-predicate list?        and 3 tag/pair)         ; low 2 bits
  107. (define-type-predicate extend?      and 3 tag/extend)
  108. (define-type-predicate immediate?   and 3 tag/immediate)
  109.  
  110. (define-type-predicate general-vector-header? header header/general-vector)
  111. (define-type-predicate bytev-header?          header header/bytev)
  112. (define-type-predicate text-header?           header header/text)
  113. (define-type-predicate string-header?         header header/slice)
  114. (define-type-predicate symbol-header?         header header/symbol)
  115. (define-type-predicate foreign-header?        header header/foreign)
  116. (define-type-predicate vcell-header?          header header/vcell)
  117. (define-type-predicate true-header?           header header/true)
  118. (define-type-predicate unit-header?           header header/unit)
  119. (define-type-predicate vframe-header?         header header/vframe)
  120. (define-type-predicate bignum-header?         header header/bignum) 
  121. (define-type-predicate double-float-header?   header header/double-float)
  122.                        
  123. (define-type-predicate weak-set-header?   header header/weak-set)
  124. (define-type-predicate weak-alist-header? header header/weak-alist)
  125. (define-type-predicate weak-table-header? header header/weak-table)
  126. (define-type-predicate weak-cell-header?  header header/weak-cell)
  127.  
  128. (define-constant char?
  129.   (primop char? ()
  130.     ((primop.test-code self node arg)
  131.      (emit m68/move .l arg SCRATCH)
  132.      (emit m68/cmp .b (machine-num header/char) SCRATCH))
  133.     ((primop.presimplify self node)
  134.      (presimplify-predicate node))
  135.     ((primop.make-closed self)
  136.      (make-closed-predicate self))
  137.     ((primop.type-predicate? self) t)
  138.     ((primop.type self node)
  139.      '#[type (proc #f (proc #f boolean) top)])
  140.     ((primop.predicate-type self node)
  141.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  142.                                                       
  143. (define-constant fixnum?
  144.   (primop fixnum? ()
  145.     ((primop.test-code self node arg)
  146.      (emit m68/move .l arg SCRATCH)
  147.      (emit m68/and .b (machine-num 3) SCRATCH))
  148.     ((primop.presimplify self node)
  149.      (presimplify-predicate node))
  150.     ((primop.make-closed self)
  151.      (make-closed-predicate self))
  152.     ((primop.type-predicate? self) t)
  153.     ((primop.type self node)
  154.      '#[type (proc #f (proc #f boolean) top)])
  155.     ((primop.predicate-type self node)
  156.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  157.                                                       
  158. (define-constant nonvalue?
  159.   (primop nonvalue? ()
  160.     ((primop.test-code self node arg)
  161.      (emit m68/move .l arg SCRATCH)
  162.      (emit m68/cmp .b (machine-num header/nonvalue) SCRATCH))
  163.     ((primop.presimplify self node)
  164.      (presimplify-predicate node))
  165.     ((primop.make-closed self)
  166.      (make-closed-predicate self))
  167.     ((primop.type-predicate? self) t)
  168.     ((primop.type self node)
  169.      '#[type (proc #f (proc #f boolean) top)])
  170.     ((primop.predicate-type self node)
  171.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  172.                                                       
  173.  
  174. (define-constant template-header?
  175.   (primop template-header? ()
  176.     ((primop.test-code self node arg)
  177.      (emit m68/move .l arg SCRATCH)
  178.      (emit m68/btst (machine-num 31) SCRATCH))
  179.     ((primop.presimplify self node)
  180.      (presimplify-predicate node))
  181.     ((primop.make-closed self)
  182.      (make-closed-predicate self))
  183.     ((primop.jump-on-equal? self) t)      
  184.     ((primop.type-predicate? self) t)
  185.     ((primop.type self node)
  186.      '#[type (proc #f (proc #f boolean) top)])
  187.     ((primop.predicate-type self node)
  188.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  189.                                                 
  190.  
  191. ;;; MAKE-VECTORS
  192. ;;;=========================================================================
  193.  
  194. (define-constant make-vector-extend
  195.   (primop make-vector-extend ()
  196.     ((primop.arg-specs self) '(* 10 1))   ;; AN and S1
  197.     ((primop.generate self node)
  198.      (generate-make-vector-extend node))))
  199.  
  200. (define-constant %make-extend
  201.   (primop %make-extend ()
  202.     ((primop.arg-specs self) '(10 1))   ;; AN and S1
  203.     ((primop.generate self node)
  204.      (generate-make-extend node))
  205.     ((primop.type self node)
  206.      '#[type (proc #f (proc #f top) template fixnum)])))
  207.  
  208. ;;; MAKE-PAIR
  209.  
  210. (define-constant %make-pair
  211.   (primop %make-pair ()
  212.     ((primop.generate self node)
  213.      (generate-make-pair node))
  214.     ((primop.type self node)
  215.      '#[type (proc #f (proc #f pair))])))
  216.  
  217. ;;; ONE-ARG-PRIMITIVES
  218. ;;;==========================================================================
  219.                       
  220. (define-constant descriptor->fixnum
  221.   (primop descriptor->fixnum ()
  222.     ((primop.generate self node)
  223.      (receive (source target rep) (one-arg-primitive node)
  224.        (let ((reg (if (eq? (reg-type target) 'scratch)
  225.                       target
  226.                       (get-register 'scratch node '*))))
  227.          (generate-move source reg)
  228.          (emit m68/and .b (machine-num #xFC) reg)
  229.          (really-rep-convert node reg 'rep/pointer target rep)
  230.          (mark-continuation node target))))
  231.     ((primop.type self node)
  232.      '#[type (proc #f (proc #f fixnum) top)])))
  233.  
  234. (define-constant descriptor-tag
  235.   (primop descriptor-tag ()
  236.     ((primop.generate self node)
  237.      (receive (source target rep) (one-arg-primitive node)
  238.        (let ((reg (if (eq? (reg-type target) 'scratch)
  239.                       target
  240.                       (get-register 'scratch node '*))))
  241.          (generate-move source reg)
  242.          (emit m68/asl .b (machine-num 2) reg)
  243.          (emit m68/and .l (machine-num #xF) reg) ; get low 4 bits
  244.          (really-rep-convert node reg 'rep/pointer target rep)
  245.          (mark-continuation node target))))
  246.     ((primop.type self node)
  247.      '#[type (proc #f (proc #f fixnum) top)])))
  248.                                            
  249. (define-constant header-type
  250.   (primop header-type ()
  251.     ((primop.generate self node)
  252.      (receive (source target rep) (one-arg-primitive node)
  253.        (let ((reg (if (eq? (reg-type target) 'scratch)
  254.                       target
  255.                       (get-register 'scratch node '*))))
  256.          (generate-move source reg)
  257.          (emit m68/and .l (machine-num #x7c) reg) ; get low 7 bits
  258.          (really-rep-convert node reg 'rep/pointer target rep) ; mask out tag
  259.          (mark-continuation node target))))
  260.     ((primop.type self node)
  261.      '#[type (proc #f (proc #f fixnum) top)])))
  262.  
  263. (define-constant %chdr
  264.   (primop %chdr ()
  265.     ((primop.side-effects? self) t)
  266.     ((primop.generate self node)
  267.      (generate-%chdr node))))
  268.                             
  269.  
  270.  
  271.  
  272.  
  273.